home *** CD-ROM | disk | FTP | other *** search
- unit Debugu;
- {$define Debugging}
-
- interface
-
- uses
- SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
- Forms, Dialogs, StdCtrls, ExtCtrls;
-
- {$ifdef Debugging}
- type
- TDebugFrm = class(TForm)
- DebugMemo: TMemo;
- procedure FormClose(Sender: TObject; var Action: TCloseAction);
- end;
-
- var
- DebugFrm: TDebugFrm;
- {$endif}
-
- procedure AssignDebug(var F: TextFile);
-
- implementation
-
- {$ifdef Debugging}
- {$R *.DFM}
- {$endif}
-
- function DebugOpen(var F: TTextRec): Integer; far; forward;
- function DebugOutput(var F: TTextRec): Integer; far; forward;
- function DebugClose(var F: TTextRec): Integer; far; forward;
-
- procedure AssignDebug(var F: TextFile);
- begin
- { Set up text file variable }
- with TTextRec(F) do
- begin
- Handle := $FFFF;
- OpenFunc := @DebugOpen;
- Mode := fmClosed;
- BufSize := SizeOf(Buffer);
- BufPtr := @Buffer;
- Name[0] := #0;
- end;
- end;
-
- function DebugOpen(var F: TTextRec): Integer;
- begin
- Result := 0;
- with F do
- begin
- if Mode = fmInput then
- { Access denied }
- Result := 5
- else
- begin
- Mode := fmOutput;
- InOutFunc := @DebugOutput;
- FlushFunc := @DebugOutput;
- end;
- CloseFunc := @DebugClose;
- end;
- {$ifdef Debugging}
- DebugFrm := TDebugFrm.Create(Application);
- {$endif}
- end;
-
- function DebugOutput(var F: TTextRec): Integer;
- var
- Buf: array[0..255] of Char;
- begin
- Result := 0;
- {$ifdef Debugging}
- { This gets called when a Delphi 2 app shuts, in closing Output }
- { Since it refers to the form which won't exist, don't run it }
- if not Application.Terminated then
- begin
- { If output form ain't showing, show it }
- if not DebugFrm.Visible then
- DebugFrm.Show;
- with F do
- begin
- StrLCopy(Buf, PChar(BufPtr), BufPos);
- DebugFrm.DebugMemo.SelText :=
- StrPas(Buf);
- BufPos := 0;
- end;
- end;
- {$endif}
- end;
-
- function DebugClose(var F: TTextRec): Integer;
- begin
- Result := 0;
- {$ifdef Debugging}
- DebugFrm.Free;
- {$endif}
- end;
-
- {$ifdef Debugging}
- procedure TDebugFrm.FormClose(Sender: TObject; var Action: TCloseAction);
- begin
- Action := caNone;
- end;
- {$endif}
-
- initialization
- AssignDebug(Output);
- Rewrite(Output);
- end.
-